Unit
	HTTPHandling;

Interface

Uses
	Classes,
	Contnrs,
	BlckSock,
	SysUtils,
	StrUtils;

Type
	THTTPRequest = Class
	Private
		fRequestLine,
		fMethod,
		fURI,
		fProtocol,
		fPOSTData : String;
		fHeaders : TFPStringHashTable;
		fVariables : TFPStringHashTable;
		fURL : String;
		fContentLength : Integer;
		fContentType : String;
		Procedure SetRequestLine(Const aRequestLine : String);
		Procedure AddVariable(Const aNameValue : String);
		Procedure SplitVariables(Const aVariables : String);
		Procedure ParseVariables(Const aURI : String);
	Public
		Constructor Create;
		Destructor Destroy; Override;
		Procedure ReadFromSocket(Const aSocket : TTCPBlockSocket);
		Procedure AddHeader(Const aHeaderLine : String);
		Property RequestLine : String Write SetRequestLine;
		Property Method : String Read fMethod;
		Property URI : String Read fURI;
		Property Protocol : String Read fProtocol;
		Property POSTData : String Read fPOSTData Write fPOSTData;
		Property Headers : TFPStringHashTable Read fHeaders;
		Property Variables : TFPStringHashTable Read fVariables;
		Property ContentLength : Integer Read fContentLength;
		Property ContentType : String Read fContentType;
	End;

	THTTPResponse = Class
	Private
		fCode : Integer;
		fReason : String;
		fProtocol : String;
		fHeaders : TFPStringHashTable;
		fContent : String;
		fContentLength : Integer;
		Procedure SetContent(Const aContent : String);
		Function CreateResponseLine : String;
	Public
		Constructor Create;
		Destructor Destroy; Override;
		Procedure WriteToSocket(Const aSocket : TTCPBlockSocket);
		Procedure AddHeader(Const aName, aValue : String);
		Property ResponseLine : String Read CreateResponseLine;
		Property Code : Integer Read fCode Write fCode;
		Property Reason : String Read fReason Write fReason;
		Property Protocol : String Read fProtocol Write fProtocol;
		Property Headers : TFPStringHashTable Read fHeaders;
		Property Content : String Read fContent Write SetContent;
		Property ContentLength : Integer Read fContentLength;
	End;

	THTTPTransaction = Class
	Private
		fSocket : TTCPBlockSocket;
		fRequest : THTTPRequest;
		fResponse : THTTPResponse;
	Public
		Constructor Create;
		Destructor Destroy; Override;
		Property Socket : TTCPBlockSocket Read fSocket Write fSocket;
		Property Request : THTTPRequest Read fRequest;
		Property Response : THTTPResponse Read fResponse;
	End;

Function URLEncodeString(Const aString : String): String;
Function URLDecodeString(Const aString : String): String;
	
Procedure CheckSocketError(Const aSocket : TTCPBlockSocket);
	
Implementation

Procedure CheckSocketError(Const aSocket : TTCPBlockSocket);
Begin
	If aSocket.LastError <> 0 Then
	Begin
		{ Debug } WriteLn(aSocket.LastErrorDesc);
		Raise Exception.Create(aSocket.LastErrorDesc);
	End;
End;

Function URLEncodeString(Const aString : String): String;
Var
	lCtrl : Integer;
Begin
	Result := '';
	For lCtrl := 1 To Length(aString) Do
		If Not(aString[lCtrl] In ['0'..'9', 'a'..'z', 'A'..'Z', '$', 
				'-', '_', '.', '+', '!', '*', '''', '(', ')', ',']) Then
			Result := Result + '%' + IntToHex(Byte(aString[lCtrl]), 2)
		Else
			Result := Result + aString[lCtrl];
End;

Function URLDecodeString(Const aString : String): String;
Var
	lTemp : String;
Begin
	Result := '';
	lTemp := aString;
	While lTemp <> '' Do
		If lTemp[1] = '%' Then
		Begin
			Delete(lTemp, 1, 1);
			Result := Result + Char(StrToInt('$' + Copy(lTemp, 1, 2)));
			Delete(lTemp, 1, 2);
		End
		Else
		Begin
			Result := Result + lTemp[1];
			Delete(lTemp, 1, 1);
		End;
End;

// THTTPRequest

Procedure THTTPRequest.SetRequestLine(Const aRequestLine : String);
Var
	lRequestLine : String;
Begin
	lRequestLine := aRequestLine;
	fRequestLine := lRequestLine;
	fMethod := UpperCase(Copy2SymbDel(lRequestLine, ' '));
	fURI := LowerCase(Copy2SymbDel(lRequestLine, ' '));
	fProtocol := UpperCase(Copy2SymbDel(lRequestLine, ' '));
	ParseVariables(fURI);
End;

Procedure THTTPRequest.AddVariable(Const aNameValue : String);
Var
	lName,
	lValue : String;
	lNameValuePair : String;
Begin
	lNameValuePair := aNameValue;
	lName := Copy2SymbDel(lNameValuePair, '=');
	lValue := lNameValuePair;
	fVariables.Add(lName, lValue);
	{ Debug } WriteLn('New variable : ', lName, '="', lValue, '"');
End;

Procedure THTTPRequest.SplitVariables(Const aVariables : String);
Var
	lNameValuePair,
	lVariables : String;
Begin
	{ Debug } WriteLn('Splitting variables.');
	lVariables := aVariables;
	While lVariables <> '' Do
		Begin
			lNameValuePair := Copy2SymbDel(lVariables, '&');
			AddVariable(lNameValuePair);
		End;
End;

Procedure THTTPRequest.ParseVariables(Const aURI : String);
Var
	lURI : String;
Begin
	lURI := aURI;
	{ Debug } WriteLn('Parsing variables. POS(?, lURI)=', Pos('?', lURI));
	If Pos('?', lURI) > 0 Then
	Begin
		fURL := Copy2SymbDel(lURI, '?');
		SplitVariables(lURI);
	End
	Else
		fURL := lURI;
End;

Constructor THTTPRequest.Create;
Begin
	Inherited Create;
	fHeaders := TFPStringHashTable.Create;
	fVariables := TFPStringHashTable.Create;
End;

Destructor THTTPRequest.Destroy;
Begin
	FreeAndNil(fHeaders);
	FreeAndNil(fVariables);
	Inherited Destroy;
End;

Procedure THTTPRequest.ReadFromSocket(Const aSocket : TTCPBlockSocket);
Var
	lLine : String;
Begin
	{ Debug } WriteLn('Reading request from socket.');
	lLine := aSocket.RecvString(1000);
	{ Debug } WriteLn('Request line : ', lLine);
	CheckSocketError(aSocket);
	SetRequestLine(lLine);
	lLine := '';
	{ Debug } WriteLn('Reading headers.');
	Repeat
		lLine := aSocket.RecvString(1000);
		{ Debug } WriteLn('Received header line : "', lLine, '"');
		CheckSocketError(aSocket);
		If lLine = '' Then
			Break
		Else
			AddHeader(lLine);
	Until lLine = '';
	If (fContentLength > 0) And (fMethod = 'POST') Then
	Begin
		fPOSTData := Space(fContentLength);
		{ Debug } WriteLn('Receiving POST data.');
		aSocket.RecvBufferEx(@fPOSTData[1], fContentLength, 1000);
		{ Debug } WriteLn('POST Data : ', fPOSTData);
		CheckSocketError(aSocket);
	End;
	If (fMethod = 'POST') And (Assigned(fHeaders.Find('content-type')) And (fHeaders.Items['content-type'] = 'application/x-www-form-urlencoded')) Then
		SplitVariables(fPOSTData);
End;

Procedure THTTPRequest.AddHeader(Const aHeaderLine : String);
Var
	lTemp,
	lName,
	lValue : String;
Begin
	lTemp := aHeaderLine;
	lName := Copy2SymbDel(lTemp, ':');
	Delete(lTemp, 1, 1);
	lValue := lTemp;
	{ Debug } WriteLn('Appending header ', LowerCase(lName), '="', lValue, '"');
	fHeaders.Add(LowerCase(lName), lValue);
	If LowerCase(lName) = 'content-length' Then
		Try
			fContentLength := StrToInt(lValue);
		Except
			On E: Exception Do
			Begin
				fContentLength := 0;
			End;
		End
	Else If LowerCase(lName) = 'content-type' Then
		fContentType := lValue;
End;

// THTTPResponse

Procedure THTTPResponse.SetContent(Const aContent : String);
Begin
	fContent := aContent;
	fContentLength := Length(aContent);
End;

Function THTTPResponse.CreateResponseLine : String;
Begin
	Result := fProtocol + ' ' + IntToStr(fCode) + ' ' + fReason;
End;

Constructor THTTPResponse.Create;
Begin
	Inherited Create;
	fHeaders := TFPStringHashTable.Create;
End;

Destructor THTTPResponse.Destroy;
Begin
	FreeAndNil(fHeaders);
	Inherited Destroy;
End;

Procedure THTTPResponse.WriteToSocket(Const aSocket : TTCPBlockSocket);
Var
	lCtrl1,
	lCtrl2 : Integer;
	lHdr : String;
Begin
	{ Debug } WriteLn('Sending response.');
	{ Debug } WriteLn('Response Line : ', ResponseLine);
	aSocket.SendString(ResponseLine + CR + LF);
	CheckSocketError(aSocket);
	fHeaders.Add('content-length', IntToStr(fContentLength));
	{ Debug } WriteLn('Sending Headers.');
	For lCtrl1 := 0 To fHeaders.HashTable.Count - 1 Do
		If Assigned(fHeaders.HashTable.Items[lCtrl1]) Then
			For lCtrl2 := 0 To (fHeaders.HashTable.Items[lCtrl1] As TFPObjectList).Count - 1 Do
			Begin
				lHdr := ((fHeaders.HashTable.Items[lCtrl1] As TFPObjectList).Items[lCtrl2] As THTStringNode).Key + ': ' +
					((fHeaders.HashTable.Items[lCtrl1] As TFPObjectList).Items[lCtrl2] As THTStringNode).Data;
				{ Debug } WriteLn('Header : "', lHdr, '"');
				aSocket.SendString(lHdr + CR + LF);
				CheckSocketError(aSocket);
			End;
	aSocket.SendString('' + CR + LF);
	CheckSocketError(aSocket);
	If fContentLength > 0 Then
	Begin
		{ Debug } WriteLn('Sending content : ', fContent);
		aSocket.SendString(fContent);
		CheckSocketError(aSocket);
	End;
End;

Procedure THTTPResponse.AddHeader(Const aName, aValue : String);
Begin
	fHeaders.Add(LowerCase(aName), aValue);
End;

// THTTPTransaction

Constructor THTTPTransaction.Create;
Begin
	Inherited Create;
	fRequest := THTTPRequest.Create;
	fResponse := THTTPResponse.Create;
End;

Destructor THTTPTransaction.Destroy;
Begin
	FreeAndNil(fRequest);
	FreeAndNil(fResponse);
	Inherited Destroy;
End;

End.